
(in-package :com.yanbo.id3v2)

;;; 二进制整型类型
(binary:define-binary-type unsigned-integer (bytes bits-per-byte)
  (:reader (in)
	   (loop with value = 0
	      for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do
		(setf (ldb (byte bits-per-byte low-bit) value) (read-byte in))
	      finally (return value)))
  (:writer (out value)
	   (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte
		do (write-byte (ldb (byte bits-per-byte low-bit) value) out))))

(binary:define-binary-type u1 () (unsigned-integer :bytes 1 :bits-per-byte 8))
(binary:define-binary-type u2 () (unsigned-integer :bytes 2 :bits-per-byte 8))
(binary:define-binary-type u3 () (unsigned-integer :bytes 3 :bits-per-byte 8))
(binary:define-binary-type u4 () (unsigned-integer :bytes 4 :bits-per-byte 8))

(binary:define-binary-type id3-tag-size () (unsigned-integer :bytes 4 :bits-per-byte 7))

;;; 通用字符串类型
(binary:define-binary-type generic-string (length character-type)
  (:reader (in)
	   (let ((string (make-string length)))
	     (dotimes (i length)
	       (setf (char string i) (binary:read-value character-type in)))
	     string))
  (:writer (out string)
	   (dotimes (i length)
	     (binary:write-value character-type out (char string i)))))

(binary:define-binary-type generic-terminated-string (terminator character-type)
  (:reader (in)
	   (with-output-to-string (s)
	     (loop for char = (binary:read-value character-type in)
		until (char= char terminator) do (write-char char s))))
  (:writer (out string)
	   (loop for char across string
	      do (binary:write-value character-type out char)
		finally (write-value character-type out terminator))))

(binary:define-binary-type iso-8859-1-char ()
  (:reader (in)
	   (let ((code (read-byte in)))
	     (or (code-char code)
		 (error "Character code ~d not supported" code))))
  (:writer (out char)
	   (let ((code (char-code char)))
	     (if (<= 0 code #xff)
		 (write-byte code out)
		 (error
		  "Illegal character for iso-8859-1 encoding: character: ~c with code: ~d" char code)))))

(binary:define-binary-type iso-8859-1-string (length)
  (generic-string :length length :character-type 'iso-8859-1-char))

(binary:define-binary-type iso-8859-1-terminated-string (terminator)
  (generic-terminated-string :terminator terminator
			     :character-type 'iso-8859-1-char))

(binary:define-binary-type ucs-2-char (swap)
  (:reader (in)
	   (let ((code (binary:read-value 'u2 in)))
	     (when swap (setf code (swap-bytes code)))
	     (or (code-char code) (error "Character code ~d not supported" code))))
  (:writer (out char)
	   (let ((code (char-code char)))
	     (unless (<= 0 code #xffff)
	       (error "Illegal character for ucs-2 encoding: ~c with char-code: ~d" char code))
	     (when swap (setf code (swap-bytes code)))
	     (binary:write-value 'u2 out code))))

(defun swap-bytes (code)
  (assert (<= code #xffff))
  (rotatef (ldb (byte 8 0) code) (ldb (byte 8 8) code))
  code)

(binary:define-binary-type ucs-2-char-big-endian () (ucs-2-char :swap nil))
(binary:define-binary-type ucs-2-char-little-endian () (ucs-2-char :swap t))

(defun ucs-2-char-type (byte-order-mark)
  (ecase byte-order-mark
    (#xfeff 'ucs-2-char-big-endian)
    (#xfffe 'ucs-2-char-little-endian)))

(binary:define-binary-type ucs-2-string (length)
  (:reader (in)
	   (let ((byte-order-mark (read-value 'u2 in))
		 (characters (1- (/ length 2))))
	     (binary:read-value
	      'generic-string in
	      :length characters
	      :character-type (ucs-2-char-type byte-order-mark))))
  (:writer (out string)
	   (binary:write-value 'u2 out #xfeff)
	   (binary:write-value
	    'generic-string out string
	    :length (length string)
	    :character-type (ucs-2-char-type #xfeff))))

(binary:define-binary-type ucs-2-terminated-string (terminator)
  (:reader (in)
	   (let ((byte-order-mark (read-value 'u2 in)))
	     (binary:read-value
	      'generic-terminated-string in
	      :terminator terminator
	      :character-type (ucs-2-char-type byte-order-mark))))
  (:writer (out string)
	   (binary:write-value 'u2 out #xfeff)
	   (binary:write-value
	    'generic-terminated-string out string
	    :terminator terminator
	    :character-type (ucs-2-char-type #xfeff))))

;;; ID3标签头
#|
(binary:define-binary-class id3-tag ()
  ((identifier (iso-8859-1-string :length 3))
   (major-version u1)
   (revision u1)
   (flags u1)
   (size id3-tag-size)))
|#
(defun read-id3 (file)
  (with-open-file (in file :element-type '(unsigned-byte 8))
    (binary:read-value 'id3-tag in)))

(defun show-tag-header (file)
  (with-slots (identifier major-version revision flags size) (read-id3 file)
    (format t "~a ~d.~d ~8,'0b ~d bytes -- ~a~%"
	    identifier major-version revision flags size (enough-namestring file))))

(defun mp3-p (file)
  (and
   (not (directory-pathname-p file))
   (string-equal "mp3" (pathname-type file))))

(defun show-tag-headers (dir)
  (walk-directory dir #'show-tag-header :test #'mp3-p))

(defun count-version (dir)
  (let ((versions (mapcar #'(lambda (x) (cons x 0)) '(2 3 4))))
    (flet ((count-version (file)
	     (incf (cdr (assoc (major-version (read-id3 file)) versions)))))
      (walk-directory dir #'count-version :test #'mp3-p))
    versions))

(defun id3-p (file)
  (with-open-file (in file :element-type '(unsigned-byte 8))
    (string= "ID3" (read-value 'iso-8859-1-string in :length 3))))
#|
(binary:define-tagged-binary-class id3-frame ()
  ((id (iso-8859-1-string :length 3))
   (size u3))
  (:dispatch (find-frame-class id)))
|#
#|
(binary:define-binary-class generic-frame (id3-frame)
  ((data (raw-bytes :size size))))
|#

(binary:define-binary-type raw-bytes (size)
  (:reader (in)
	   (let ((buf (make-array size :element-type '(unsigned-byte 8))))
	     (read-sequence buf in)
	     buf))
  (:writer (out buf)
	   (write-sequence buf out)))
#|
(defun find-frame-class (id)
  (declare (ignore id))
	   'generic-frame)
|#
#|
(binary:define-binary-type id3-frames (tag-size)
  (:reader (in)
	   (loop with to-read = tag-size
	      while (plusp to-read)
	      for frame = (read-frame in)
	      while frame
	      do (decf to-read (+ 6 (size frame)))
	      collect frame
	      finally (loop repeat (1- to-read) do (read-byte in))))
  (:writer (out frames)
	   (loop with to-write = tag-size
	      for frame in frames
	      do (binary:write-value 'id3-frame out frame)
		(decf to-write (+ 6 (size frame)))
	      finally (loop repeat to-write do (write-byte 0 out)))))
|#
#|
(binary:define-binary-class id3-tag ()
  ((identifier (iso-8859-1-string :length 3))
   (major-version u1)
   (revision u1)
   (flags u1)
   (size u1)
   (frames (id3-frames :tag-size size))))
|#
(binary:define-binary-type frame-id (length)
  (:reader (in)
	   (let ((first-byte (read-byte in)))
	     (when (= first-byte 0) (signal 'in-padding))
	     (let ((rest (binary:read-value 'iso-8859-1-string in :length (1- length))))
	       (concatenate
		'string (string (code-char first-byte)) rest))))
  (:writer (out id)
	   (binary:write-value 'iso-8859-1-string out id :length length)))
#|
(binary:define-tagged-binary-class id3-frame ()
  ((id (frame-id :length 3))
   (size u3))
  (:dispatch (find-frame-class id)))
|#
#|
(defun read-frame (in)
  (handler-case (read-value 'id3-frame in)
    (in-padding () nil)))
|#
;;;;; support multiple version ;;;;;
(binary:define-tagged-binary-class id3-tag ()
  ((identifier (iso-8859-1-string :length 3))
   (major-version u1)
   (revision u1)
   (flags u1)
   (size id3-tag-size))
  (:dispatch
   (case major-version
     (2 'id3v2.2-tag)
     (3 'id3v2.3-tag)
     (4 'id3v2.4-tag)
     (otherwise (error "May be id3v1 tag.")))))

(binary:define-binary-class id3v2.2-tag (id3-tag)
  ((frames (id3-frames :tag-size size :frame-type 'id3v2.2-frame))))

(binary:define-binary-type optional (type if)
  (:reader (in)
	   (when if (binary:read-value type in)))
  (:writer (out value)
	   (when if (binary:write-value type out value))))

(binary:define-binary-class id3v2.3-tag (id3-tag)
  ((extended-header-size (optional :type 'u4 :if (extended-p flags)))
   (extra-flags (optional :type 'u2 :if (extended-p flags)))
   (padding-size (optional :type 'u4 :if (extended-p flags)))
   (crc (optional :type 'u4 :if (crc-p flags extra-flags)))
   (frames (id3-frames :tag-size size :frame-type 'id3v2.3-frame))))

(defun extended-p (flags)
  (logbitp 6 flags))

(defun crc-p (flags extra-flags)
  (and (extended-p flags) (logbitp 15 extra-flags)))

(binary:define-binary-type id3-frames (tag-size frame-type)
  (:reader (in)
	   (loop with to-read = tag-size
	      while (plusp to-read)
	      for frame = (read-frame frame-type in)
	      while frame
	      do (decf to-read (+ (frame-header-size frame) (size frame)))
	      collect frame
	      finally (loop repeat (1- to-read) do (read-byte in))))
  (:writer (out frames)
	   (loop with to-write = tag-size
	      for frame in frames
	      do (binary:write-value frame-type out frame)
		(decf to-write (+ (frame-header-size frame) (size frame)))
	      finally (loop repeat to-write do (write-byte 0 out)))))

(defun read-frame (frame-type in)
  (handler-case (binary:read-value frame-type in)
    (in-padding () nil)))

(define-condition in-padding () ())

(defgeneric frame-header-size (frame))

;;;;; frame base class of version ;;;;;
(binary:define-tagged-binary-class id3v2.2-frame ()
  ((id (frame-id :length 3))
   (size u3))
  (:dispatch (find-frame-class id)))

(binary:define-tagged-binary-class id3v2.3-frame ()
  ((id (frame-id :length 4))
   (size u4)
   (flags u2)
   (decompressed-size (optional :type 'u4 :if (frame-compressed-p flags)))
   (encryption-scheme (optional :type 'u1 :if (frame-encrypted-p flags)))
   (grouping-identity (optional :type 'u1 :if (frame-grouped-p flags))))
  (:dispatch (find-frame-class id)))

(defun frame-compressed-p (flags) (logbitp 7 flags))
(defun frame-encrypted-p (flags) (logbitp 6 flags))
(defun frame-grouped-p (flags) (logbitp 5 flags))

(defmethod frame-header-size ((frame id3v2.2-frame)) 6)
(defmethod frame-header-size ((frame id3v2.3-frame)) 10)

;;;;;;;;;;;;;; special frame of version ;;;;;;;;;;;;;;;
(binary:define-binary-class generic-frame-v2.2 (id3v2.2-frame)
  ((data (raw-bytes :size size))))

(binary:define-binary-class generic-frame-v2.3 (id3v2.3-frame)
  ((data (raw-bytes :size size))))

(binary:define-binary-class generic-frame ()
  ((data (raw-bytes :size (data-bytes (current-binary-object))))))

(defgeneric data-types (frame))

(defmethod data-types ((frame id3v2.2-frame))
  (size frame))

(defmethod data-bytes ((frame id3v2.3-frame))
  (let ((flags (flags frame)))
    (- (size frame)
       (if (frame-compressed-p flags) 4 0)
       (if (frame-encrypted-p flags) 1 0)
       (if (frame-grouped-p flags) 1 0))))

(binary:define-binary-class generic-frame-v2.2 (id3v2.2-frame generic-frame) ())
(binary:define-binary-class generic-frame-v2.3 (id3v2.3-frame generic-frame) ())
#|
(defun find-frame-class (id)
  (ecase (length id)
    (3 'generic-frame-v2.2)
    (4 'generic-frame-v2.3)))
|#
;;;;;;;;;;;;; those frames you needed in fact ;;;;;;;;;;;;;;;;;
(defun frame-types (file)
  (delete-duplicates (mapcar #'id (frames (read-id3 file))) :test #'string=))

(defun frame-types-in-dir (dir)
  (let ((ids ()))
    (flet ((collect (file)
	     (setf ids (nunion ids (frame-types file) :test #'string=))))
      (walk-directory dir #'collect :test #'mp3-p))
    ids))

;;;;;;;;;;;;;;;; text information frame ;;;;;;;;;;;;;;;;;;
(defun non-terminated-type (encoding)
  (ecase encoding
    (0 'iso-8859-1-string)
    (1 'ucs-2-string)))

(defun terminated-type (encoding)
  (ecase encoding
    (0 'iso-8859-1-terminated-string)
    (1 'ucs-2-terminated-string)))

(defun string-args (encoding length terminator)
  (cond
    (length
     (values (non-terminated-type encoding) :length length))
    (terminator
     (values (terminated-type encoding) :terminator terminator))))

(binary:define-binary-type id3-encoded-string (encoding length terminator)
  (:reader (in)
	   (multiple-value-bind (type keyword arg)
	       (string-args encoding length terminator)
	     (binary:read-value type in keyword arg)))
  (:writer (out string)
	   (multiple-value-bind (type keyword arg)
	       (string-args encoding length terminator)
	     (binary:write-value type out string keyword arg))))

(binary:define-binary-class text-info-frame ()
  ((encoding u1)
   (information (id3-encoded-string :encoding encoding :length (bytes-left 1)))))

(defun bytes-left (bytes-read)
  (- (size (current-binary-object)) bytes-read))

(binary:define-binary-class text-info-frame-v2.2 (id3v2.2-frame text-info-frame) ())
(binary:define-binary-class text-info-frame-v2.3 (id3v2.3-frame text-info-frame) ())
#|
(defun find-frame-class (name)
  (cond
    ((and (char= (char name 0) #\T)
	  (not (member name '("TXX" "TXXX") :test #'string=)))
     (ecase (length name)
       (3 'text-info-frame-v2.2)
       (4 'text-info-frame-v2.3)))
    (t
     (ecase (length name)
       (3 'generic-frame-v2.2)
       (4 'generic-frame-v2.3)))))
|#
;;;;;;;;;;;;;;;; debate frame ;;;;;;;;;;;;;;;;;;;;;;
(binary:define-binary-class comment-frame ()
  ((encoding u1)
   (language (iso-8859-1-string :length 3))
   (description (id3-encoded-string :encoding encoding :terminator +null+))
   (text (id3-encoded-string
	  :encoding encoding
	  :length (bytes-left
		   (+ 1 ;encoding
		      3 ;language
		      (encoded-string-length description encoding t)))))))

(defun encoded-string-length (string encoding terminated)
  (let ((characters (+ (length string) (if terminated 1 0))))
    (* characters (ecase encoding (0 1) (1 2)))))

(binary:define-binary-class comment-frame-v2.2 (id3v2.2-frame comment-frame) ())
(binary:define-binary-class comment-frame-v2.3 (id3v2.3-frame comment-frame) ())

(defun find-frame-class (name)
  (cond
    ((and (char= (char name 0) #\T)
	  (not (member name '("TXX" "TXXX") :test #'string=)))
     (ecase (length name)
       (3 'text-info-frame-v2.2)
       (4 'text-info-frame-v2.3)))
    ((string= name "COM") 'comment-frame-v2.2)
    ((string= name "COMM") 'comment-frame-v2.3)
    (t
     (ecase (length name)
       (3 'generic-frame-v2.2)
       (4 'generic-frame-v2.3)))))

(defun upto-null (string)
  (subseq string 0 (position +null+ string)))
#|
(defun find-frame (id3 id)
  (find id (frames id3) :test #'string= :key #'id))

(defun get-text-info (id3 id)
  (let ((frame (find-frame id3 id)))
    (when frame (upto-null (information frame)))))

;it adapte id3v2.2 only
(defun song (id3) (get-text-info id3 "TT2"))
|#

(defun find-frame (id3 ids)
  (find-if #'(lambda (x) (find (id x) ids :test #'string=)) (frames id3)))

(defun get-text-info (id3 &test ids)
  (let ((frame (find-frame id3 ids)))
    (when frame (upto-null (information frame)))))

(defun song (id3) (get-text-info id3 "TT2" "TIT2"))

;;;;; functions will be used in chapter 27 ;;;;;
(defun album (id3) (get-text-info id3 "TAL" "TALB"))
(defun artist (id3) (get-text-info id3 "TP1" "TPE1"))
(defun track (id3) (get-text-info id3 "TRK" "TRCK"))
(defun year (id3) (get-text-info id3 "TYE" "TYER" "TDRC"))
(defun genre (id3) (get-text-info id3 "TCO" "TCON"))

(defun translated-genre (id3)
  (let ((genre (genre id3)))
    (if (and genre (char= #\( (char genre 0)))
	(translate-v1-genre genre)
	genre)))

(defun translate-v1-genre (genre)
  (aref *id3-v1-genre* (parse-integer genre :start 1 :junk-allowed t)))

(defparameter *id3-v1-genres*
  #(
    ;; These are the official ID3v1 genres
    "Blues" "Classic Rock" "Country" "Dance" "Disco" "Funk" "Grunge" "Hip-Hop" "Jazz" "Metal" "New Age" "Oldies" "Other" "Pop" "R&B" "Rap" "Reggae" "Rock" "Techno" "Inustrial" "Alternative" "Ska" "Death Metal" "Pranks" "Soundtrack" "Euro-Techno" "Ambient" "Trip-Hop" "Vocal" "Jazz+Funk" "Fusion" "Trance" "Classical" "Instrumental Pop" "Instrumental Rock" "Ethnic" "Gothic" "Darkwave" "Techno-Industrial" "Electronic" "Pop-Folk" "Eurodance" "Dream" "Southern Rock" "Comedy" "Cult" "Gangsta" "Top 40" "Christian Rap" "Pop/Funk" "Jungle" "Native American" "Cabaret" "New Wave" "Psychedelic" "Rave" "Showtunes" "Trailer" "Lo-Fi" "Tribal" "Acid Punk" "Acid Jazz" "Polka" "Retro" "Musical" "Rock & Roll" "Hard Rock"
    ;; These were made up by the authors of Winamp but backported into the ID3 spec.
    "Folk" "Folk--Rock" "National Folk" "Swing" "Fast Fusion" "Bebob" "Latin" "Revival" "Celtic" "Bluegrass" "Avantgarde" "Gothic Rock" "Progressive Rock" "Psychedelic Rock" "Symphonic Rock" "Slow Rock" "Big Band" "Chorus" "Easy Listening" "Acoustic" "Humor" "Speech" "Chanson" "Opera" "Chamber Music" "Sonata" "Symphony" "Booty Bass" "Primus" "Porn Groove" "Aatire" "Slow Jam" "Club" "Tango" "Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul" "Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella" "Euro-House" "Dance Hall"

    ;; These were also invented by the Winamp folks but ignored by the ID3 authors.
    "Goa" "Drum & Bass" "Club-House" "Hardoore" "Terror" "Indie" "BritPop" "Negerpunk" "Polsk Punk" "Beat" " Christian Gangsta Rap" "Heavy Metal" "Black Metal" "Crossover" "Contemporary Christian" "Christian Rock" "Merengue" "Salsa" "Thrash Metal" "Anime" "Jpop" "Synthpop"))

#|
(defvar music1 "h:/music/xuehaizi.mp3")
(defvar music2 "h:/music/sixiang.mp3")
(defvar music3 "h:/music/zhangyipiaopiao.mp3")

(id3v2:read-id3 music1)
(id3v2:read-id3 music2)
(id3v2:read-id3 music3)

(id3v2:show-tag-header music1)
(id3v2:show-tag-header music2)
(id3v2:show-tag-header music3)

(id3v2:count-version music1)
(id3v2:frame-types music3)
(id3v2:frame-types-in-dir "h:/music/")

(id3v2:count-version music2)
(id3v2:frame-types music2)
|#

